######################################################################
#
# wt::web package
#
######################################################################

package require wt::core

namespace eval ::wt::web:: {
  namespace export htmlEncode urlEncode urlDecode \
    serverUrl absoluteUrl relativeUrl selfUrl \
    setUrlParameters
}

# Create a URL using the current server values as the defaults

proc ::wt::web::serverUrl {parts} {
  set url ""

  if {[table has $parts protocol]} {
    set protocol [table get $parts protocol]
  } else {
    if {[serverVars get HTTPS ""] == "on"} {
      set protocol https
    } else {
      set protocol http
    }
  }

  append url "$protocol://"

  if {[table has $parts user]} {
    set user [table get $parts user]
  } else {
    set user [serverVars get AUTH_USER ""]
  }

  if {$user != ""} {
    append url $user
  }

  set password [table get $parts password ""]
  if {$password != ""} {
    append url ":$password"
  }

  if {$user != "" || $password != ""} {
    append url @
  }

  if {[table has $parts host]} {
    set host [table get $parts host]
  } else {
    set host [serverVars get HTTP_HOST]
  }

  append url $host

  if {[table has $parts path]} {
    set path [table get $parts path]
  } else {
    set path [serverVars get SCRIPT_NAME]
    append path [severVars get PATH_INFO]
  }

  append url $path

  if {[table has $parts query]} {
    set query [table get $parts query]
  } else {
    set query [serverVars get QUERY_STRING ""]
  }

  if {$query != ""} {
    append url "?$query"
  }

  set fragment [table get $parts fragment ""]

  if {$fragment != ""} {
    append url "#$fragment"
  }

  return $url
}

# Create an absolute URL from a path and parameter list

proc ::wt::web::absoluteUrl {path params {fragment {}}} {
  set parts [table create path $path \
    params [listToQueryString $params] \
    fragment $fragment]
  return [serverUrl $parts]
}

# Create a relative URL from a path and parameter list

proc ::wt::web::relativeUrl {path params {fragment {}}} {
  if {$path == ""} {
    set path .
  }
  set url $path
  if {[llength $params]} {
    append url "?[listToQueryString $params]"
  }
  if {$fragment != ""} {
    append url "#$fragment"
  }
  return $url
}

# key-value list into query string

proc ::wt::web::listToQueryString {params} {
  set qs ""
  foreach {k v} $params {
    if {$qs != ""} {
      append qs &
    }
    append qs "[urlEncode $k]=[urlEncode $v]"
  }
  return $qs
}

# Link to the current page

proc ::wt::web::selfUrl {args} {
  set usage 0
  set start -1
  set html 0
  set replace 1

  for {set i 0} {$i < [llength $args]} {incr i} {
    set arg [lindex $args $i]
    if {$arg == "-html"} {
      if {$html == 1} {
        set usage 1
        break
      }
      set html 1
    } elseif {$arg == "-noreplace"} {
      if {$replace == 0} {
        set usage 1
        break
      }
      set replace 0
    } elseif {$arg == "--"} {
      set start [expr $i + 1]
    } elseif {[string index $arg 0] == "-"} {
      set usage 1
      break
    } else {
      set start $i
    }
    if {$start != -1} {
      if {$start < [expr [llength $args] - 1]} {
        set usage 1
      } else {
        set params [lindex $args $start]
      }
      break
    }
  }

  if {$usage} {
    error "Usage: selfUrl ?-html? ?-noreplace? ?parameterList?"
  }

  set url [wt::server::serverVars get REQUEST_URI]
  if {[info exists params]} {
    return [setUrlParameters $url $params $replace]
  }
  if {$html} {
    set url [htmlEncode $url]
  }

  return $url
}

# Modify the values in a query string

proc ::wt::web::setUrlParameters {url params {replace 1}} {
  foreach {k v} $params {
    if {$replace && ![info exists seen($k)]} {
      set keyPtn [wt::util::escapeRegexp [urlEncode $k]]
      set url [regsub -all "(\[&\?\])${keyPtn}(=\[^&\]*)?(&|\$)" $url {\1}]
    }
    set end [string index $url end]
    if {$end != "?" && $end != "&"} {
      if {[string first & $url] != -1} {
        append url &
      } else {
        append url ?
      }
    }
    append url "[urlEncode $k]=[urlEncode $v]"
    set seen($k) 1
  }

  return $url
}

# Return the tail part of a URL path

proc ::wt::web::pathBasename {path} {
  return [regsub {^(.*?)([^/\\]*)$} $path {\2}]
}

# Limited HTML printing functions. Consider using TclDOM or
# tcllib::html.

# Print a select control

proc ::wt::web::printSelect {sel} {
  set options [table get $sel options]

  set selectedValues [table get $sel selectedValues {}]
  foreach val $selectedValues {
    set selectedArray($val) 1
  }

  set isMulti [table get $sel isMulti 0]
  set found 0
  set optionsHtml ""

  for {set i 0} {$i < [llength $options]} {set i [expr $i + 2]} {
    set value [lindex $options $i]
    set attrs {}
    lappend attrs value $value
    if {[info exists selectedArray($value)] && ($isMulti || !$found)} {
      lappend attrs selected 1
      set found 1
    }
    set opt [printTag option $attrs]
    set label [lindex $options [expr $i + 1]]
    append opt $label
    append optionsHtml "$opt "
  }

  set attrs [table get $sel attributes ""]
  lappend attrs name [table get $sel name]
  if {$isMulti} {
    lappend attrs multiple 1
  }

  set styleProps [table get $sel styleProps ""]

  set select [printTag select $attrs $styleProps $optionsHtml]
  return $select
}

# Print a radio button

proc ::wt::web::printRadio {name value checked {attributes {}} \
    {styleProps {}}} {
  lappend attributes type radio name $name value $value
  if {$checked} {
    lappend attributes checked 1
  }
  printTag input $attributes $styleProps
}

# Print an HTML tag

proc ::wt::web::printTag {name {attributes {}} {styleProps {}} \
    {innerHtml {}}} {
  set str "<[htmlEncode $name]"

  set styleStr [printStyleProperties $styleProps]
  if {$styleStr != ""} {
    set new {}
    for {set i 0} {$i < [llength $attributes]} {set i [expr $i + 2]} {
      if {[lindex $attributes $i] != "style"} {
        lappend new [lindex $attributes $i] \
          [lindex $attributes [expr $i + 1]]
      }
    }
    lappend new style $styleStr
    set attributes $new
  }

  set attrStr [printTagAttributes $attributes]
  if {$attrStr != ""} {
    append str " $attrStr"
  }
  append str ">"

  if {$innerHtml != ""} {
    append str $innerHtml
    append str "</[htmlEncode $name]>"
  }

  return $str
}

# Print tag attributes

proc ::wt::web::printTagAttributes {attributes} {
  set str ""
  for {set i 0} {$i < [llength $attributes]} {set i [expr $i + 2]} {
    if {$str != ""} {
      append str " "
    }
    append str [htmlEncode [lindex $attributes $i]]
    append str "=\"[htmlEncode [lindex $attributes [expr $i + 1]]]\""
  }
  return $str
}

# Print style properties

proc ::wt::web::printStyleProperties {properties} {
  set str ""
  for {set i 0} {$i < [llength $properties]} {set i [expr $i + 2]} {
    if {$str != ""} {
      append str ";"
    }
    append str [htmlEncode [lindex $properties $i]]
    append str ":[htmlEncode [lindex $properties [expr $i + 1]]]"
  }
  return $str
}

package provide wt::web 1
